home *** CD-ROM | disk | FTP | other *** search
/ Gekikoh Dennoh Club 5 / Gekikoh Dennoh Club Vol. 5 (Japan).7z / Gekikoh Dennoh Club Vol. 5 (Japan) (Track 01).bin / docs / rakup / match.vl < prev    next >
Lisp/Scheme  |  1998-10-03  |  3KB  |  130 lines
  1. ;
  2. ; match.vl : âpâ^ü[âôâ}âbâ`âôâO
  3. ;
  4. ;            Copyright (C) 1998 by Makoto Hiroi
  5. ;
  6.  
  7. ;
  8. ; üEò╧Éöé═ëpæσò╢ÄÜé┼Äné▄éΘâVâôâ{âï
  9. ; üEɼî≈é═ò╧Éöæ⌐ö¢é≡ò╘é╖
  10. ; üEÄ╕ösé═ fail é≡ò╘é╖
  11. ; üEû│û╝ò╧Éöé═û│é╡
  12. ;
  13.  
  14. ;
  15. ; ò╧Éöé≡â`âFâbâNé╖éΘ
  16. ; 
  17. (defun variablep (pattern)
  18.   (and (symbolp pattern)
  19.        (upper-case-p (char pattern 0))))
  20.  
  21. ;
  22. ; ò╧Éöæ⌐ö¢é╔Æ╟ë┴é╖éΘ
  23. ;
  24. (defun add-binding (var value binding)
  25.   (cons (cons var value) binding))
  26.  
  27. ;
  28. ; â}âbâ`âôâO : datum é╔ò╧Éöé═û│é╡
  29. ;
  30. (defun match (pattern datum binding)
  31.   (cond ((variablep pattern)
  32.          (match-variable pattern datum binding))
  33.         ((and (atom pattern) (atom datum))
  34.          (match-atoms pattern datum binding))
  35.         ((and (consp pattern) (consp datum))
  36.          (match-pieces pattern datum binding))
  37.         (t 'fail)))
  38.  
  39. ;
  40. ; ò╧Éöé╞é╠â}âbâ`âôâO
  41. ;
  42. (defun match-variable (var datum binding)
  43.   (let ((value (assoc var binding)))
  44.     (if value
  45.         ; Ælé≡Ägé┴é─éαéñêΩôxâ`âFâbâN
  46.         (match (cdr value) datum binding)
  47.         ; ò╧Éöæ⌐ö¢é╔Æ╟ë┴é╖éΘ
  48.         (add-binding var datum binding))))
  49.  
  50. ;
  51. ; âAâgâÇô»Ämé╠â}âbâ`âôâO
  52. ;
  53. (defun match-atoms (pattern datum binding)
  54.   (if (equal pattern datum) binding 'fail))
  55.  
  56. ;
  57. ; âèâXâgô»Ämé╠â}âbâ`âôâO
  58. ;
  59. (defun match-pieces (pattern datum binding)
  60.   (let ((result (match (car pattern) (car datum) binding)))
  61.     (if (eq result 'fail)
  62.         'fail
  63.         (match (cdr pattern) (cdr datum) result))))
  64.  
  65.  
  66. ;
  67. ; âåâjâtâBâPü[âVâçâô : pattern, datum é╞éαé╔ò╧Éöé¬ôⁿé┴é─éóéΘ
  68. ;
  69. (defun unify (pattern datum binding)
  70.   (cond ((variablep pattern)
  71.          (unify-variable pattern datum binding))
  72.         ((variablep datum)
  73.      (unify-variable datum pattern binding))
  74.         ((and (atom pattern) (atom datum))
  75.          (unify-atoms pattern datum binding))
  76.         ((and (consp pattern) (consp datum))
  77.          (unify-pieces pattern datum binding))
  78.         (t 'fail)))
  79.  
  80. ;
  81. ; âAâgâÇé╞é╠âåâjâtâBâPü[âVâçâô
  82. ;
  83. (defun unify-atoms (pattern datum binding)
  84.   (if (equal pattern datum) binding 'fail))
  85.  
  86. ;
  87. ; âèâXâgé╠âåâjâtâBâPü[âVâçâô
  88. ;
  89. (defun unify-pieces (pattern datum binding)
  90.   (let ((result (unify (car pattern) (car datum) binding)))
  91.     (if (eq result 'fail)
  92.         'fail
  93.         (unify (cdr pattern) (cdr datum) result))))
  94.  
  95. ;
  96. ; ò╧Éöé╞é╠âåâjâtâBâPü[âVâçâô
  97. ;
  98. (defun unify-variable (pattern datum binding)
  99.   (let ((value (assoc pattern binding)))
  100.     (if (and value
  101.              ; ((X . X) ... ) é┼û│î└âïü[âvé╔é╚éτé╚éóéµéñé╔é╖éΘé╜é▀
  102.              (not (eq pattern (cdr value))))
  103.         (unify (cdr value) datum binding)
  104.         (if (insidep pattern datum binding)
  105.             'fail
  106.             (add-binding pattern datum binding)))))
  107.  
  108. ;
  109. ; datum é╠Æåé╔ var(ò╧Éö)é¬éáéΘé⌐
  110. ;
  111. (defun insidep (var datum binding)
  112.   (if (eq var datum)
  113.       nil
  114.       (inside-sub-p var datum binding)))
  115.  
  116.  
  117. (defun inside-sub-p (var datum binding)
  118.   (cond ((equal var datum) t)
  119.         ((atom datum) nil)
  120.         ((variablep datum)
  121.          (let ((value (assoc datum binding)))
  122.            (if value
  123.                (inside-sub-p var (cdr value) binding))))
  124.         (t ; list é╠ÅΩìç
  125.          (or (inside-sub-p var (car datum) binding)
  126.              (inside-sub-p var (cdr datum) binding)))))
  127.                     
  128.  
  129. ; end of file
  130.